home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trmode.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  10.3 KB  |  332 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;; gjc: 6:27pm  sunday, 20 july 1980
  10. ;;;       (c) copyright 1979 massachusetts institute of technology       ;;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. (in-package "MAXIMA")
  14.  
  15.  
  16. (macsyma-module trmode)
  17.  
  18.  
  19. (transl-module trmode)
  20. (defmvar $mode_checkp t "if true, modedeclare checks the modes of bound variables.")
  21. (defmvar $mode_check_warnp t "if true, mode errors are described.")
  22. (defmvar $mode_check_errorp nil "if true, modedeclare calls error.")
  23.  
  24. (defmvar $macsyma_extend_warnp t "if true,
  25. warning given about not-built-in modes being taken for MACSYMA EXTEND types.")
  26.  
  27. (defun mseemingly-unbound (x)
  28.   (or (not (boundp x)) (eq (symbol-value x) x)))
  29.  
  30. (defmfun assign-mode-check (var value)
  31.   (let ((mode (get var 'mode))
  32.     (user-level ($get var '$value_check)))
  33.     (if mode
  34.     (let (($mode_check_warnp t)
  35.           ($mode_check_errorp t))
  36.       (chekvalue var mode value)))
  37.     (if user-level
  38.     (mcall user-level value)))
  39.   value)
  40.  
  41. (DEFTRVAR DEFINED_VARIABLES ())
  42.  
  43. (DEFTRVAR $DEFINE_VARIABLE ())
  44.  
  45. (DEF%TR $DEFINE_VARIABLE (FORM) ;;VAR INIT MODE.
  46.   (COND ((> (LENGTH FORM) 3)
  47.      (LET (((VAR VAL MODE) (CDR FORM)))
  48.        (LET ((SPEC-FORM `(($DECLARE) ,VAR $SPECIAL))
  49.          (MODE-FORM `(($MODEDECLARE) ,VAR ,MODE)))
  50.          (translate spec-form)
  51.          (translate mode-form)
  52.          (PUSH-PRE-TRANSL-FORM
  53.           ;; POSSIBLE OVERKILL HERE
  54.           `(declare (special ,VAR)))
  55.          (PUSH VAR DEFINED_VARIABLES)
  56.          ;; Get rid of previous definitions put on by
  57.          ;; the translator.
  58.          (DO ((L *PRE-TRANSL-FORMS* (CDR L)))
  59.          ((NULL L))
  60.            ;; REMOVE SOME OVERKILL
  61.            (COND ((AND (EQ (CAAR L) 'DEF-MTRVAR)
  62.                (EQ (CADAR L) VAR))
  63.               (SETQ *PRE-TRANSL-FORMS*
  64.                 (DELQ (CAR L) *PRE-TRANSL-FORMS*)))))
  65.          (if (not (eq mode '$any))
  66.          ;; so that the rest of the translation gronks this.
  67.          (putprop var 'assign-mode-check 'assign))
  68.          `($any . (eval-when (compile eval load)
  69.                  (meval* ',mode-form)
  70.                  (meval* ',spec-form)
  71.                  ,(if (not (eq mode '$any))
  72.                   `(defprop ,var
  73.                      assign-mode-check
  74.                      assign))
  75.                  (def-mtrvar ,(cadr form)
  76.                    ,(dtranslate (caddr form))
  77.                    )))
  78.          )))
  79.     (t
  80.      (TR-TELL "Wrong number of arguments" form)
  81.      nil)))
  82.  
  83. #-CL
  84. ;; Not needed on LISPM because the MACRO definition is in effect.
  85. ;; For NIL we must do some fexpr abstraction anyway.
  86. (defun def-mtrvar fexpr (l)
  87.   (LET (((V A . IGNORE-CRUFTY) L))
  88.     ;; priority of setting is obsolete, but must be around for
  89.     ;; old translated files. i.e. TRMODE version < 69.
  90.     (if (mseemingly-unbound v)
  91.     (set v (eval a))
  92.     (SYMBOL-VALUE v))))
  93.  
  94. ;; the priority fails when a DEF-MTRVAR is done, then the user
  95. ;; sets the variable, because the set-priority stays the same.
  96. ;; This causes some Define_Variable's to over-ride the user setting,
  97. ;; but only in the case of re-loading, what we were worried about
  98. ;; is pre-setting of variables of autoloading files.
  99.  
  100. (defmspec $define_variable  (l) (setq l (cdr l))
  101.   (or (> (length l) 2)
  102.       (merror "Wrong number of arguments to DEFINE_VARIABLE"))
  103.   (or (symbolp (car l))
  104.       (merror "First arg to DEFINE_VARIABLE not a SYMBOL."))
  105.   (meval `(($modedeclare) ,(car l) ,(caddr l)))
  106.   (meval `(($declare) ,(car l) $special))
  107.   (if (not (eq (caddr l) '$any))
  108.       (putprop (car l) 'assign-mode-check 'assign))
  109.   (if (mseemingly-unbound (car l))
  110.       (meval `((msetq) ,(car l) ,(cadr l)))
  111.       (meval (car l))))
  112.  
  113.  
  114. (DEFMSPEC $MODE_IDENTITY (L) (SETQ L (CDR L))
  115.   (OR (= (LENGTH L) 2) (MERROR "MODE_IDENTITY takes 2 arguments."))
  116.   (LET* ((obj (cadr l)) (V (MEVAL obj)))
  117.     (CHEKVALUE obj (ir-or-extend (CAR L)) V)
  118.     V))
  119.  
  120.  
  121. (DEF%TR $MODE_IDENTITY (FORM)
  122.   `(,(ir-or-extend (CADR FORM)) . ,(DTRANSLATE (CADDR FORM))))
  123.  
  124. (defun ir-or-extend (x)
  125.   (let ((built-in-type (CASE X
  126.                   (($FLOAT $REAL $FLOATP $FLONUM $FLOATNUM) '$FLOAT)
  127.                   (($FIXP $FIXNUM $integer) '$FIXNUM)
  128.                   (($RATIONAL $RAT) '$RATIONAL)
  129.                   (($NUMBER $BIGNUM $BIG) '$NUMBER)
  130.                   (($BOOLEAN $BOOL) '$BOOLEAN)
  131.                   (($LIST $LISTP) '$LIST)
  132.                   ($complex '$complex)
  133.                   (($ANY $NONE $ANY_CHECK) '$ANY))))
  134.     (if built-in-type built-in-type
  135.     (prog1 x
  136.            (if $macsyma_extend_warnp
  137.            (mtell
  138.             "WARNING: ~M is not a built-in type; assuming it is a MACSYMA EXTEND type" x))))))
  139.  
  140. (DEF%TR $MODEDECLARE (FORM)
  141.   (DO ((L (CDR FORM) (CDDR L))) ((NULL L))
  142.       (DECLMODE (CAR L) (ir-or-extend (CADR L)) T)))
  143.  
  144. (DEFMFUN ASS-EQ-REF N
  145.   (LET ((VAL (ASSQ (ARG 2) (ARG 1))))
  146.           (IF VAL (CDR VAL)
  147.           (IF (= N 3) (ARG 3) NIL))))
  148.  
  149. (DEFMFUN ASS-EQ-SET (VAL TABLE KEY)
  150.      (LET ((CELL (ASSQ KEY TABLE)))
  151.           (IF CELL (SETF (CDR CELL) VAL)
  152.           (PUSH (CONS KEY VAL) TABLE)))
  153.      TABLE)
  154.  
  155.  
  156. ;;; Possible calls to MODEDECLARE.
  157. ;;; MODEDECLARE(<oblist>,<mode>,<oblist>,<mode>,...)
  158. ;;; where <oblist> is:
  159. ;;; an ATOM, signifying a VARIABLE.
  160. ;;; a LIST, giving a list of objects of <mode>
  161. ;;;
  162.  
  163. (DEFMSPEC $MODEDECLARE (X) (SETQ X (CDR X))
  164.     (IF (ODDP (LENGTH X))
  165.         (MERROR "MODE_DECLARE takes an even number of arguments."))
  166.     (DO ((L X (CDDR L)) (NL))
  167.         ((NULL L) (CONS '(MLIST) (NREVERSE NL)))
  168.         (DECLMODE (CAR L) (ir-or-extend (CADR L)) NIL)
  169.         (SETQ NL (CONS (CAR L) NL))))
  170.  
  171. (DEFUN TR-DECLARE-VARMODE (VARIABLE MODE)
  172.   (DECLVALUE VARIABLE (ir-or-extend MODE) T))
  173.  
  174. ;;; If TRFLAG is TRUE, we are in the translator, if NIL, we are in the
  175. ;;; interpreter.
  176. (DECLARE-TOP (SPECIAL TRFLAG MODE FORM))
  177. (DEFUN DECLMODE (FORM MODE TRFLAG)
  178.   (COND ((ATOM FORM)
  179.      (DECLVALUE FORM MODE TRFLAG)
  180.      (AND (NOT TRFLAG) $MODE_CHECKP (CHEKVALUE FORM MODE)))
  181.     ((EQ 'MLIST (CAAR FORM))
  182.      (MAPC #'(LAMBDA (L)
  183.             (DECLMODE L MODE TRFLAG))
  184.            (CDR FORM)))
  185.     ((MEMQ 'array (CDAR FORM))
  186.      (DECLARRAY (CAAR FORM) MODE))
  187.     ((EQ '$FUNCTION (CAAR FORM))
  188.      (MAPC #'(LAMBDA (L)
  189.             (DECLFUN L MODE))
  190.            (CDR FORM)))
  191.     ((MEMQ (CAAR FORM) '($FIXED_NUM_ARGS_FUNCTION
  192.                  $VARIABLE_NUM_ARGS_FUNCTION))
  193.      (MAPC #'(LAMBDA (F)
  194.             (DECLFUN F MODE)
  195.             (MPUTPROP F T (CAAR FORM)))
  196.            (CDR FORM)))
  197.     ((EQ '$COMPLETEARRAY (CAAR FORM))
  198.      (MAPC #'(LAMBDA (L)
  199.             (PUTPROP (COND ((ATOM L) L)
  200.                        (T (CAAR L)))
  201.                  MODE 'ARRAY-MODE))
  202.            (CDR FORM)))
  203.     ((EQ '$ARRAY (CAAR FORM))
  204.      (MAPC #'(LAMBDA (L) (MPUTPROP L MODE 'ARRAY-MODE)) (CDR FORM)))
  205.     ((EQ '$ARRAYFUN (CAAR FORM))
  206.      (MAPC #'(LAMBDA (L) (MPUTPROP L MODE 'ARRAYFUN-MODE)) (CDR FORM)))
  207.     (T
  208.      (DECLFUN (CAAR FORM) MODE))))
  209. (declare-top (UNSPECIAL TRFLAG MODE FORM))
  210.  
  211. (DEFTRFUN DECLVALUE (V MODE TRFLAG)
  212.   (IF TRFLAG (SETQ V (TEVAL V)))
  213.   (ADD2LNC V $PROPS)
  214.   (PUTPROP V MODE 'MODE))
  215.  
  216.  
  217. (DEFMFUN CHEKVALUE (V MODE
  218.               &optional
  219.               (val (meval1 v) val-givenp))
  220.   (COND ((or val-givenp (not (eq v val)))
  221.      ; hack because macsyma PROG binds variable
  222.      ; to itself. 
  223.      (let ((CHECKER (ASSQ MODE `(($FLOAT . FLOATP)
  224.                      ($FIXNUM . INTEGERP)
  225.                      ($NUMBER . NUMBERP)
  226.                      ($LIST . $LISTP)
  227.                      ($BOOLEAN . ,#'(LAMBDA (U)
  228.                                (MEMQ U '(T NIL)))))))
  229.            (nchecker (assq mode '(($float . $real)
  230.                       ($fixnum . $integer)
  231.                       ($complex . $complex))))
  232.            (extend-type ($extendp val))
  233.            (not-done t))
  234.        (if (cond (extend-type
  235.               (cond ((eql mode '$any) nil)
  236.                 (t (not (eql mode extend-type)))))
  237.              ((AND CHECKER
  238.                (NOT (FUNCALL (CDR CHECKER) VAL))
  239.                (if nchecker
  240.                    (prog1
  241.                 (not (mfuncall '$featurep val (cdr nchecker)))
  242.                 (setq not-done nil))
  243.                    t)))
  244.              ((if not-done (and nchecker (not (mfuncall '$featurep val (cdr nchecker)))))))
  245.            (SIGNAL-MODE-ERROR V MODE VAL))))))
  246.  
  247.  
  248. (DEFUN SIGNAL-MODE-ERROR (OBJECT MODE VALUE)
  249.        (COND ((AND $MODE_CHECK_WARNP
  250.            (NOT $MODE_CHECK_ERRORP))
  251.           (MTELL "Warning: ~:M was declared mode ~:M, has value: ~M"
  252.              OBJECT MODE VALUE))
  253.          ($MODE_CHECK_ERRORP
  254.           (MERROR "Error: ~:M was declared mode ~:M, has value: ~M"
  255.               OBJECT MODE VALUE))))
  256.               
  257. (DEFUN PUT-MODE (NAME MODE TYPE)
  258.        (IF (GET NAME 'TBIND)
  259.        (SETF (GET NAME 'VAL-MODES)
  260.          (ASS-EQ-SET MODE (GET NAME 'VAL-MODES) TYPE))
  261.        (SETF (GET NAME TYPE) MODE)))
  262.  
  263. (DEFUN DECLARRAY (AR MODE)
  264.        (PUT-MODE AR MODE 'ARRAY-MODE))
  265.  
  266. (DEFUN DECLFUN (F MODE) (PUT-MODE F MODE 'FUNCTION-MODE))
  267.  
  268. ;;; 1/2 is not $RATIONAL. bad name. it means CRE form.
  269.  
  270. (DEFUN IR (X)
  271.        (CASE X
  272.           (($FLOAT $REAL $FLOATP $FLONUM $FLOATNUM) '$FLOAT)
  273.           (($FIXP $FIXNUM) '$FIXNUM)
  274.           (($RATIONAL $RAT) '$RATIONAL)
  275.           (($NUMBER $BIGNUM $BIG) '$NUMBER)
  276.           (($BOOLEAN $BOOL) '$BOOLEAN)
  277.           (($LIST $LISTP) '$LIST)
  278.           (($ANY $NONE $ANY_CHECK) '$ANY)
  279.           (T (UDM-ERR X) X)))
  280.  
  281. (DEFUN UDM-ERR (MODE)
  282.        (MTELL "Warning:  ~:M is not a known mode declaration ~
  283.           maybe you want ~:M mode.~%"
  284.           MODE
  285.           (CASE MODE
  286.              (($INTEGER $INTEGERP) '$FIXNUM)
  287.              (($COMPLEX) "&to ask about this")
  288.              (($FUCKED $SHITTY) "&to watch your language")
  289.              (T "&to see the documentation on"))))
  290.  
  291. (DEFUN IR (X)
  292.   (CASE X
  293.      (($FLOAT $REAL $FLOATP $FLONUM $FLOATNUM) '$FLOAT)
  294.      (($FIXP $FIXNUM) '$FIXNUM)
  295.      (($RATIONAL $RAT) '$RATIONAL)
  296.      (($NUMBER $BIGNUM $BIG) '$NUMBER)
  297.      (($BOOLEAN $BOOL) '$BOOLEAN)
  298.      (($LIST $LISTP) '$LIST)
  299.      (($ANY $NONE $ANY_CHECK) '$ANY)
  300.      (T (UDM-ERR X) X)))
  301.  
  302. (DEFUN UDM-ERR (MODE)
  303.   (MTELL "Warning:  ~:M is not a known mode declaration ~
  304. maybe you want ~:M mode.~%"
  305.      MODE
  306.      (CASE MODE
  307.         (($INTEGER $INTEGERP) '$FIXNUM)
  308.         (($COMPLEX) "&to ask about this")
  309.         (($FUCKED $SHITTY) "&to watch your language")
  310.         (T "&to see the documentation on"))))
  311.  
  312. (DEFMFUN FLUIDIZE (VARIABLE)
  313.   (MAPC #'(LAMBDA (V) (OR (BOUNDP V) (SET V ())))
  314.     ;; what a sorry crock to have all these switches.
  315.       '(*IN-COMPILE*
  316.     *IN-COMPFILE*
  317.     *IN-TRANSLATE*
  318.     *IN-TRANSLATE-FILE*))
  319.  
  320.   (PUTPROP VARIABLE T 'SPECIAL)
  321.   (IF (AND $TRANSCOMPILE
  322.        (OR *IN-COMPILE*
  323.            *IN-COMPFILE*
  324.            *IN-TRANSLATE*
  325.            *IN-TRANSLATE-FILE*))
  326.       (ADDL VARIABLE SPECIALS)))
  327.  
  328. (DEFMSPEC $BIND_DURING_TRANSLATION (FORM)
  329.   (MEVALN (CDDR FORM)))
  330.  
  331.  
  332.